home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / PBSELECT.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  9KB  |  284 lines
  1. {SECTION ..PbSELECT }
  2. UNIT PbSELECT;
  3.  
  4. INTERFACE
  5.  
  6. USES CRT, PbCRT, PbMISC, PbDATA, PbOBJS, PbHIGH, PbWIND;
  7.  
  8. {
  9. Description:  Selection window stuff.
  10.  
  11. Author      : Howard Richoux
  12. Date        : 12/18/90
  13. Last revised: 1/12/94 Combined PbSELECT and FSELstuf
  14.               2/18/94 NEW LIBRARIES
  15. Application : IBM PC and compatibles, done in Turbo Pascal 7.0
  16. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  17. Published in: none
  18. }
  19.  
  20.  
  21.  
  22. Procedure SetSelectWindow(xx0,xy0,xrows,xcols,xwidth : integer);
  23.            {[CRT] Sets up window size}
  24.  
  25. Procedure SetSelectWindowLabels(xtoplabel,xbottomlabel : string);
  26.            {[CRT] Sets up window labels}
  27.  
  28.  
  29. Procedure Select(var items : STRA_object; var s : string; var n : integer;
  30.                      var cmd : string);
  31.            {[CRT] Displays items, returns selection}
  32.  
  33. Procedure SelectWText(var items,itemtexts : STRA_object;
  34.                  var s : string; var n : integer; var cmd : string);
  35.            {[CRT] Displays items and supporting text, returns selection}
  36.  
  37. Procedure SelectFile(Template : string; var s : string;
  38.              var itemselect : integer; max,sortmode : integer; var cmd : string);
  39.            {[CRT] Displays a list of files for choice, optional sorting }
  40.  
  41.  
  42. {SECTION .zzImplementation }
  43. IMPLEMENTATION
  44.  
  45.  
  46.  
  47. var wx0, wy0, rows, cols, wwidth, textwidth : integer;
  48. var itemselect, dispmax, savebase, itembase, itemline  : integer;
  49. var toplabel,bottomlabel   : string[60];
  50.  
  51.  
  52. Procedure Normalize(count : integer;
  53.                     var  itemselect,itembase,itemline : integer);
  54.      begin
  55.      if itemselect < 1 then itemselect := 1;
  56.      if itemselect > count then itemselect := count;
  57.      itembase := (itemselect div dispmax) * dispmax;
  58.      itemline := itemselect mod dispmax;
  59.      itemselect := itembase + itemline;
  60.      if itemline < 1 then itemline := 1;
  61.      end;
  62.  
  63.  
  64. Procedure MakeSelectWindow(count : integer; var wndw : WINDOW_object);
  65. var err,xcols,xrows : integer;
  66.      begin
  67.      savebase := -1;
  68.      xcols := (cols*(wwidth+2)) + textwidth + 1;
  69.      xrows :=  rows+2;
  70.      wndw.init(wx0,wy0,wx0+xcols,wy0+xrows,0);
  71.      wndw.setlabels(toplabel,bottomlabel);
  72.      wndw.PopUp;
  73.      wndw.smallwindow;
  74.      Normalize(count,itemselect,itembase,itemline);
  75.      end;
  76.  
  77.  
  78.  
  79. Procedure DisplayItems(var items,itemtext : STRA_object; itemselect : integer);
  80. var i,j,k,l,x,y    : integer;
  81.     selectstr      : string[3];
  82.     s,s1,selectedname : string[70];
  83.      begin
  84.      if savebase <> itembase then clrscr;
  85.      x := 1; y := 1;
  86.      if items.count < 1 then
  87.          begin
  88.          writeln('Nothing to display.');
  89.          writeln('');
  90.          exit;
  91.          end;
  92.      PromptColor;
  93.      for i := 1 to rows do
  94.          begin
  95.          for j := 0 to cols-1 do
  96.               begin
  97.               k := (i + j*rows) + itembase;
  98.               if (k) <= items.count then
  99.                    begin
  100.                    selectstr := '   ';
  101.                    s := items.fetchN(k);
  102.                    if itemline=(k-itembase) then
  103.                         begin
  104.                         selectedname := leftstr(s,wwidth);
  105.                         gotoxy(2+j*(wwidth+2),i);
  106.                         EntryColor;
  107.                         x := wherex;
  108.                         y := wherey;
  109.                         write(leftstr(s,wwidth));
  110.                         PromptColor;
  111.                         end
  112.                    else begin
  113.                         gotoxy(2+j*(wwidth+2),i);
  114.                         write(leftstr(s,wwidth));
  115.                         end;
  116.                    if savebase <> itembase then
  117.                         begin
  118.                         s1 := itemtext.fetchN(k);
  119.                         if (textwidth > 0 ) and (s <> '') then
  120.                                write('  ',leftstr(s1,textwidth));
  121.                         end;
  122.                    end
  123.               end;
  124.          end;
  125.      gotoxy(1,rows+1);write(' [',integerstr(itemselect,4),'] ');
  126.      gotoxy(x,y);
  127.      savebase := itembase;
  128.      end;
  129.  
  130.  
  131.  
  132. Procedure SelectItem(var items,itemtext : STRA_object; var cmd : string;
  133.                      var item : string; var itemnumber : integer);
  134. var done  : boolean;
  135.     s, CmdString : string[40];
  136.      begin
  137.      CmdString := cmd;
  138.      itemselect := itemnumber;
  139.      Normalize(items.count,itemselect,itembase,itemline);
  140.      item := '';
  141.      done := false;
  142.      while not done do
  143.           begin
  144.           if (CmdString = '') or (CmdString = '?RESELECT') then
  145.                begin
  146.                DisplayItems(items,itemtext,itemselect);
  147.                CmdString := '?RESELECT';
  148.                GetKeyCmd(CmdString);
  149.                end;
  150.  
  151.           if (CmdString = '?ESCAPE') then
  152.                begin
  153.                itemselect := 0;
  154.                item := '';
  155.                done := true;
  156.                cmd := '?ESCAPE';
  157.                end
  158.           else if (CmdString = '?HOME')   then   itemselect := 1
  159.           else if (CmdString = '?END')    then   itemselect := items.count
  160.           else if (CmdString = '?UPARR')  then   itemselect := itemselect -1
  161.           else if (CmdString = '?DOWNARR') then  itemselect := itemselect +1
  162.           else if (CmdString = '?UP')      then
  163.                                       itemselect := itemselect - dispmax
  164.           else if (CmdString = '?DOWN')   then
  165.                                       itemselect := itemselect + dispmax
  166.           else if (CmdString = '?RIGHTARR')  then
  167.                                       itemselect := itemselect + rows
  168.           else if (CmdString = '?LEFTARR')  then
  169.                                       itemselect := itemselect - rows
  170.           else if (copy(CmdString,1,3) = '?FK')  then
  171.                begin
  172.                cmd := cmdstring;
  173.                done := true;
  174.                end
  175.           else begin
  176.                if itemselect < 1 then itemselect := 1;
  177.                if itemselect > items.count then itemselect := items.count;
  178.                cmd := '?SELECTED';
  179.                done := true;
  180.                end;
  181.           CmdString := '?RESELECT';
  182.           if itemselect <> 0 then
  183.                begin
  184.                Normalize(items.count,itemselect,itembase,itemline);
  185.                item := items.fetchN(itemselect);
  186.                end;
  187.           end;
  188.      if item = '' then itemselect := 0;
  189.      itemnumber := itemselect;
  190.      end;
  191.  
  192.  
  193.  
  194. {SECTION  SetSelectWindow }
  195. Procedure SetSelectWindow(xx0,xy0,xrows,xcols,xwidth : integer);
  196.      begin
  197.      wx0    := xx0;
  198.      wy0    := xy0;
  199.      rows   := xrows;
  200.      cols   := xcols;
  201.      wwidth := xwidth;
  202.      dispmax := rows * cols;
  203.      end;
  204.  
  205.  
  206.  
  207. {SECTION  SetSelectWindowLabels }
  208. Procedure SetSelectWindowLabels(xtoplabel,xbottomlabel : string);
  209.      begin
  210.      if xtoplabel <> '' then toplabel := xtoplabel;
  211.      if xbottomlabel <> '' then bottomlabel := xbottomlabel;
  212.      end;
  213.  
  214.  
  215.  
  216. {SECTION  Select }
  217. Procedure Select(var items : STRA_object; var s : string; var n : integer;
  218.                      var cmd : string);
  219. var itemtext : STRA_object;
  220. var wndw     : WINDOW_object;
  221.      begin
  222.      itemtext.init(items.count);
  223.      itemselect := n;
  224.      textwidth := 0;
  225.      s := '';
  226.      MakeSelectWindow(items.count, wndw);  { wndw will be initted here }
  227.      cmd := '?RESELECT';
  228.      DisplayItems(items,itemtext,n);
  229.      SelectItem(items,itemtext,cmd,s,n);
  230.      s := UpCaseStr(s);
  231.      wndw.done;
  232.      end;
  233.  
  234.  
  235.  
  236. {SECTION  SelectWText }
  237. Procedure SelectWText(var items,itemtexts : STRA_object;
  238.                  var s : string; var n : integer; var cmd : string);
  239. var wndw     : WINDOW_object;
  240.      begin
  241.      itemselect := n;
  242.      s := '';
  243.      textwidth := 70-wwidth;
  244.      MakeSelectWindow(items.count, wndw);  { wndw will be initted here }
  245.      cmd := '?RESELECT';
  246.      DisplayItems(items,itemtexts,n);
  247.      SelectItem(items,itemtexts,cmd,s,n);
  248.      s := UpCaseStr(s);
  249.      wndw.done;
  250.      end;
  251.  
  252.  
  253.  
  254.  
  255. {SECTION  SelectFile }
  256. Procedure SelectFile(Template : string; var s : string;
  257.              var itemselect : integer; max,sortmode : integer; var cmd : string);
  258. var files : STRA_object;
  259.      begin
  260.      files.init(max);
  261.      GetFilesSTRA(Template, files,sortmode);
  262.      Select(files,s,itemselect,cmd);
  263.      files.done;
  264.      end;
  265.  
  266.  
  267.  
  268. {SECTION  zPbSELECTInit }
  269. Procedure zPbSELECTInit;
  270.      begin
  271.      textwidth := 0;
  272.      savebase  := -1;
  273.      toplabel       := ' Select Item ';
  274.      bottomlabel    := ' (Esc/Enter/Arrows&Page) ';
  275.      SetSelectWindow(5,5,8,4,12);
  276.      end;
  277.  
  278.  
  279.  
  280. {SECTION  zzInitialization }
  281.      begin {initialization}
  282.      zPbSELECTInit;
  283.      end.
  284.